home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / tvtoys04.zip / RESTEST.PAS < prev    next >
Pascal/Delphi Source File  |  1993-12-18  |  17KB  |  496 lines
  1. (***************************************************************************
  2.   ResTest program
  3.   Official playground, odd bits and pieces, resources, config files etc
  4.   PJB October 8, 1993, Internet mail to d91-pbr@nada.kth.se
  5.   Copyright 1993, All Rights Reserved
  6.   Free source, use at your own risk.
  7.   If modified, please state so if you pass this around.
  8.  
  9.   Demonstrates video config files, resource fonts and video tests
  10.   configurability. This program doesn't look for VESA and V7 without
  11.   being told to do so, it saves the desktop video state and it gives
  12.   transparent user access to resource fonts. There is also a self
  13.   modifying menu.
  14.  
  15.   StoreCfg is currently used before ResDemoApp.Done so that no config
  16.   file is saved if the program aborts during initialization. This
  17.   was intended to prevent unnecessary elimination of video checks,
  18.   whether that is any good I don't know.
  19.  
  20.   Another approach is to save a config file before testing that says
  21.   no testing should be done, and another after the testing with full
  22.   testing enabled. This doesn't leave anything to the user, but the
  23.   program might crash the first time, if the video BIOS is picky.
  24.  
  25.     if not ConfigOK then    { No config file }
  26.     begin
  27.       StoreCfg;             { VideoTypesToCheck is [] }
  28.       VideoTypesToCheck:=[vtVesa,vtVideo7];
  29.     end;
  30.  
  31.     inherited Init;
  32.  
  33.     if not ConfigOK then    { No config file }
  34.       StoreCfg;             { VideoTypesToCheck is [vtVesa,vtVideo7] }
  35.  
  36.  
  37.   Be careful about using TV's message box in StoreCfg, though, there
  38.   might not be any application:
  39.  
  40.     if (S.Status<>stOK) and (Application<>Nil) then
  41.       MessageBox(...)
  42.  
  43.  
  44. ***************************************************************************)
  45. program ResTest;
  46.  
  47. {$I toyCfg}
  48.  
  49. {$B-,X+}
  50.  
  51. {$IFNDEF ResFonts}
  52.   Psst! Define ResFonts in TOYCFG.PAS, or this demo is gets boring!
  53. {$ENDIF}
  54.  
  55.   uses
  56.     App, Dialogs, Drivers, Menus, MsgBox, Objects, Views,
  57.     toyPrefs, {$I hcFile}
  58.     ColorBox, ColorSel,         (* Color selection dialog *)
  59.     TVPal, Pal,                 (* Palette changing dialog *)
  60.     FontDlg, FontFiles, HelpFile, ModeDlg, StrmRec, toyApp, toyUtils,
  61.     TVVideo, TVUtils, Vesa, Video;
  62.  
  63.   type
  64.     TResDemoApp =
  65.       object (TToyApp)
  66.         ResFile   : TResourceFile;
  67.         LinesMenu : PMenu;
  68.         constructor Init;
  69.         procedure InitMenubar; virtual;
  70.         procedure CalcLinesMenu;
  71.         procedure CreateResourceFile;
  72.         procedure HandleEvent(var Event:TEvent); virtual;
  73.         procedure StoreCfg;
  74.         procedure VideoTestsDialog(VT:SpecialVideoTypes);
  75.       end;
  76.  
  77.  
  78.   (*******************************************************************
  79.     Demo commands
  80.   *******************************************************************)
  81.   const
  82.     toyStart     = 100;
  83.     cm8p         = toyStart+0;
  84.     cm14p        = toyStart+1;
  85.     cm16p        = toyStart+2;
  86.     cmVideoMode  = toyStart+3;
  87.     cmVideoInfo  = toyStart+4;
  88.     cmSelectFont = toyStart+5;
  89.     cmVideoTests = toyStart+6;
  90.     cm12p        = toyStart+7;
  91.     cmColor      = toyStart+8;
  92.     cmPalette    = toyStart+9;
  93.  
  94.   const
  95.     CfgName      = 'RESTEST.CFG';
  96.     ResName      = 'RESTEST.REZ';
  97.  
  98.  
  99. (***************************************************************************
  100.   Things that belong in a unit
  101. ***************************************************************************)
  102.  
  103.   (*******************************************************************
  104.     Restore a video state from stream
  105.   *******************************************************************)
  106.   procedure LoadVideoState(var S:TStream);
  107.     var
  108.       W : Word;
  109.       TVVideoState : VideoState;
  110.   begin
  111.     LoadVideoModes(S);
  112.  
  113.     S.Read(TVVideoState, SizeOf(TVVideoState));
  114.     S.Read(LastFontNameLoaded, SizeOf(LastFontNameLoaded));
  115.     PToyApp(Application)^.LoadPalette(S);  (* requires Application <> Nil *)
  116.     VideoPalette.Load(S);
  117.     S.Read(LastFontTypeUsed, SizeOf(LastFontTypeUsed));
  118.  
  119.     if S.Status=stOK then
  120.       TVVideoState.Restore;
  121.   end;
  122.  
  123.  
  124.   (*******************************************************************
  125.     Store current video state on a stream
  126.   *******************************************************************)
  127.   procedure StoreVideoState(var S:TStream);
  128.     var
  129.       TVVideoState : VideoState;
  130.   begin
  131.     StoreVideoModes(S);
  132.  
  133.     TVVideoState.Save;
  134.     S.Write(TVVideoState, SizeOf(TVVideoState));
  135.     S.Write(LastFontNameLoaded, SizeOf(LastFontNameLoaded));
  136.     PToyApp(Application)^.StorePalette(S);
  137.     VideoPalette.Store(S);
  138.     S.Write(LastFontTypeUsed, SizeOf(LastFontTypeUsed));
  139.   end;
  140.  
  141.  
  142. (***************************************************************************
  143.   The application
  144. ***************************************************************************)
  145.  
  146.   (*******************************************************************
  147.     Init app, load a config file with video info if there (this is
  148.     what messes it up), create resource file if necessary
  149.     This code includes TToyApp's Init, so we call TApplication.Init
  150.     directly.
  151.     Ideally we don't call TApplication.Init at all, but rather init
  152.     the app first (without calling InitVideo) and then decide what
  153.     kind of video initalizing we want...
  154.   *******************************************************************)
  155.   constructor TResDemoApp.Init;
  156.     var
  157.       S         : TDosStream;
  158.       ConfigOK  : Boolean;
  159.       InitState : VideoState;
  160.   begin
  161.     Application:=@Self;         (* Cheat, cheat, cheat... (for LoadVideoState) *)
  162.  
  163.     RegisterObjects;
  164.     RegisterFontFile;
  165.     RegisterHelpFile;
  166.  
  167.     (*******************************************************************
  168.       Open and read config file if there is one
  169.     *******************************************************************)
  170.     { Do we have a config file? }
  171.     S.Init(ExeDir+CfgName, stOpenRead);
  172.     { This zeros VideoTypesToCheck if no cfg file, so checks only EVGA }
  173.     S.Read(VideoTypesToCheck, SizeOf(VideoTypesToCheck));
  174.  
  175.     CheckVideoType;             (* Determine video type *)
  176.     InitState.Save;             (* Use temporary variable... *)
  177.  
  178.     VideoPalette.Init;          (* Initialize palette *)
  179.  
  180.     LoadVideoState(S);          (* Load previously saved video state *)
  181.     S.Done;
  182.     ConfigOK:=S.Status=stOK;
  183.  
  184.     (*******************************************************************
  185.       Init app, TToyApp replacement code
  186.     *******************************************************************)
  187.     if ConfigOK then
  188.     begin
  189.       PreventModeSwitch;        (* We loaded a new video mode *)
  190.       VideoPalette.SetRGB(VideoPalette.RGB);
  191.     end;
  192.  
  193.     TApplication.Init;          (* We don't want to call TToyApp.Init *)
  194.     DosVideoState:=InitState;   (* Save startup video mode *)
  195.  
  196.     (* Get ScreenMode (if there is no cfg file) *)
  197.     ScreenMode:=GetSpecialVideoMode;
  198.  
  199.     (*******************************************************************
  200.       Introductory text
  201.     *******************************************************************)
  202.     HelpFileName:='HELPTEST.HLP';
  203.     ShowHelp(hcRezIntro);
  204.  
  205.     (*******************************************************************
  206.       Is there a resource file?  No? Create it!
  207.     *******************************************************************)
  208.     S.Init(ExeDir+ResName, stOpenRead);
  209.     S.Done;
  210.     if S.Status<>stOK then
  211.       CreateResourceFile;        { No, create it }
  212.  
  213.     (*******************************************************************
  214.       Open the resource file
  215.     *******************************************************************)
  216.     ResFile.Init(New(PBufStream, Init(ExeDir+ResName, stOpenRead, 1024)));
  217.  
  218.     if ResFile.Stream^.Status<>stOK then      (* OOPS! *)
  219.     begin
  220.       MessageBox(^C'Resource file not readable', Nil, mfError+mfOKButton);
  221.       Done;
  222.       Halt;
  223.     end;
  224.  
  225.     (*******************************************************************
  226.       Reload last font, might need resource file
  227.     *******************************************************************)
  228.     LastFontResourceFile:=@ResFile;
  229.     VideoModeChanged:=ReloadFontAndPalette;    (* This is important! *)
  230.     VideoModeChanged;
  231.  
  232.     (*******************************************************************
  233.       Disable some features on non VGA cards
  234.     *******************************************************************)
  235.     if VideoType=Other then
  236.       DisableCommands([cmVideoMode, cmSelectFont, cm8p, cm12p, cm14p, cm16p]);
  237.     if VideoType=EGA then
  238.       DisableCommands([cm16p]);
  239.  
  240.     if VideoType=Other then
  241.       MessageBox('This program intended for EGA/VGA', Nil, mfInformation+mfOKButton);
  242.  
  243.     (*******************************************************************
  244.       No config file, ask user for action
  245.     *******************************************************************)
  246.     if not ConfigOK then
  247.       VideoTestsDialog([vtVesa,vtVideo7]);
  248.   end;
  249.  
  250.  
  251.   (*******************************************************************
  252.     Create a Video menu with whatever lines settings available.
  253.     Notice that menus are created bottom-to-top.
  254.     It's impossible to make accurate predictions about the number
  255.     of lines after a font change, the hardware might change the
  256.     number of scanlines...
  257.   *******************************************************************)
  258.   procedure TResDemoApp.CalcLinesMenu;
  259.     var
  260.       P         : PMenuItem;
  261.  
  262.     (* Add "## lines" to menu list *)
  263.     procedure Add(Points:Integer; Command, HelpCtx:Word);
  264.       function Check:String;
  265.       begin
  266.         if Points=Mem[Seg0040:CrtPoints] then
  267.           Check:='√ '
  268.         else
  269.           Check:='  ';
  270.       end;
  271.     begin
  272.       P:=NewItem(Check+ToStr(VideoScanLines div Points)+' lines', '',
  273.                  kbNoKey, Command, HelpCtx, P);
  274.     end;
  275.  
  276.   begin
  277.     DisposeMenuItems(LinesMenu^.Items);
  278.  
  279.     P:=
  280.       NewLine(
  281.       NewItem('Select ~f~ont...', '', kbNoKey, cmSelectFont, hctoyVSelectFont,
  282.       NewLine(
  283.       NewItem('Select video ~m~ode...', '', kbNoKey, cmVideoMode, hctoyVVideoMode,
  284.       Nil))));
  285.  
  286.     Add(8,  cm8p,  hctoyV8p);
  287.     Add(12, cm12p, hcNoContext);
  288.     Add(14, cm14p, hctoyV14p);
  289.     if VideoType=VGA then
  290.       Add(16, cm16p, hctoyV16p);
  291.  
  292.     LinesMenu^.Items:=P;
  293.     LinesMenu^.Default:=P;
  294.   end;
  295.  
  296.  
  297.   (*******************************************************************
  298.     There was an error writing the resource
  299.   *******************************************************************)
  300.   procedure ErrorInStream; far;
  301.   begin
  302.     MessageBox(^C'Failed to create resource file', Nil, mfError+mfOKButton);
  303.     Application^.Done;
  304.     Halt;
  305.   end;
  306.  
  307.  
  308.   (*******************************************************************
  309.     Create a resource file with one font and the corresponding
  310.     list of font resource keys
  311.   *******************************************************************)
  312.   procedure TResDemoApp.CreateResourceFile;
  313.     var
  314.       C : TStringCollection;
  315.     procedure AddFont(Name:String);
  316.       var
  317.         Font : TFontFile;
  318.     begin
  319.       C.Insert(NewStr(Name));            (* Save the resource key *)
  320.       Font.Init;
  321.       if Font.DoRead(Name+'.COM') then
  322.       begin
  323.         Font.Desc:=Name+', this is a font resource!';
  324.         ResFile.Put(@Font, Name)
  325.       end
  326.       else
  327.       begin
  328.         MessageBox(^C'Failed to read font '+Name, Nil, mfError+mfOKButton);
  329.         ResFile.Stream^.Error(stWriteError, 0);
  330.       end;
  331.     end;
  332.   begin
  333.     Notice('', ^M^M^C'Creating resource file...');
  334.  
  335.     StreamError:=@ErrorInStream;
  336.     ResFile.Init(New(PBufStream, Init(ExeDir+ResName, stCreate, 1024)));
  337.  
  338.     C.Init(10,10);
  339.  
  340.     AddFont('CHIC12');
  341.  
  342.     ResFile.Put(@C, toyFontListKey);    (* FontDlg needs this *)
  343.     ResFile.Done;
  344.     StreamError:=Nil;
  345.  
  346.     NoNotice;
  347.     MessageBox(^C'Resource file created.', Nil, mfInformation+mfOKButton);
  348.   end;
  349.  
  350.  
  351.   (*******************************************************************
  352.     Commands
  353.   *******************************************************************)
  354.   procedure TResDemoApp.HandleEvent;
  355.  
  356.     (*******************************************************************
  357.       This is the Color selection dialog
  358.     *******************************************************************)
  359.     procedure Colors;
  360.       var
  361.         D : PColorBox;
  362.     begin
  363.       D:=New(PColorBox, Init(
  364.         ColorGroup('Desktop',
  365.           DeskTopColorItems(nil),
  366.         ColorGroup('Menus',
  367.           MenuColorItems(nil),
  368.         ColorGroup('Dialogs',
  369.           DialogColorItems(dpGrayDialog, nil),
  370.         HelpColorItems(
  371.         nil))))));
  372.  
  373.       ExecuteDialog(D, GetPalette);
  374.     end;
  375.  
  376.     const
  377.       InternalArr : array [cm8p..cm16p] of Byte =
  378.         (Internal8x8Font, Internal8x14Font, Internal8x16Font);
  379.   begin
  380.     inherited HandleEvent(Event);
  381.  
  382.     if Event.What=evCommand then
  383.     begin
  384.       case Event.Command of
  385.         cm8p..cm16p:   TVVideo.SetInternalFont(InternalArr[Event.Command]);
  386.         cm12p:         LoadResFont(@ResFile, 'CHIC12');
  387.  
  388.         cmColor:       Colors;
  389.         cmPalette:
  390.           ExecuteDialog(New(PVideoPaletteDialog, Init(0)), @VideoPaletteData);
  391.  
  392.         cmSelectFont:  SelectFontDialog(ExeDir, @ResFile);
  393.         cmVideoMode:
  394.           if not HasToScan or               (* Already scanned *)
  395.              VesaScanningPossible or        (* VESA handles it *)
  396.              (MessageBox(^C'Have to do some tests. There is'+
  397.                          ^M^C'no guarantee that it works...', Nil,
  398.                          mfWarning+mfOkCancel)=cmOK) then
  399.           begin
  400.             SetUpVideoList;
  401.             SelectVideoModeDialog;
  402.           end;
  403.         cmVideoTests: VideoTestsDialog(VideoTypesToCheck);
  404.         else
  405.           Exit;
  406.       end;
  407.       ClearEvent(Event);
  408.       CalcLinesMenu;
  409.     end;
  410.   end;
  411.  
  412.  
  413.   (*******************************************************************
  414.     Menu bar
  415.   *******************************************************************)
  416.   procedure TResDemoApp.InitMenubar;
  417.     var
  418.       R : TRect;
  419.   begin
  420.     GetExtent(R);
  421.     R.B.Y:=R.A.Y+1;
  422.     MenuBar:=New(PMenuBar, Init(R, NewMenu(
  423.       NewSubMenu('~F~ile', hcNoContext, NewMenu(
  424.         NewItem('~D~OS shell', '', kbNoKey, cmDosShell, hcDosShell,
  425.         NewItem('E~x~it', 'Alt+X', kbAltX, cmQuit, hcExit,
  426.         Nil))),
  427.       NewSubMenu('~V~ideo', hcVideo,
  428.         StorePointer(LinesMenu, NewMenu(          (* Create it later *)
  429.         Nil)),
  430.       NewSubMenu('~O~ptions', hcNoContext, NewMenu(
  431.         NewItem('~C~olors...', '', kbNoKey, cmColor, hcNoContext,
  432.         NewItem('~P~alette...', '', kbNoKey, cmPalette, hctoyVPDialogHelp,
  433.         NewItem('~V~ideo detection...', '', kbNoKey, cmVideoTests, hctoyOVideoTests,
  434.         Nil)))),
  435.     Nil))))));
  436.     CheckScanLines;
  437.     CalcLinesMenu;
  438.   end;
  439.  
  440.  
  441.   (*******************************************************************
  442.     Store CFG file
  443.   *******************************************************************)
  444.   procedure TResDemoApp.StoreCfg;
  445.     var
  446.       S:TDosStream;
  447.   begin
  448.     S.Init(ExeDir+CfgName, stCreate);
  449.     S.Write(VideoTypesToCheck, SizeOf(VideoTypesToCheck));
  450.     StoreVideoState(S);
  451.     S.Done;
  452.  
  453.     if (S.Status<>stOK) and (Application<>Nil) then
  454.       MessageBox(^C'Could not create comfiguration file', Nil, mfError+mfOKButton);
  455.   end;
  456.  
  457.  
  458.   (*******************************************************************
  459.     Ask user what video detection we want
  460.  
  461.     You might feel inclined to add this:
  462.  
  463.       VESAVersion:=0;
  464.       Video7:=False;
  465.       CheckVideoType;
  466.       ScreenMode:=GetScreenMode;      { This one is important }
  467.  
  468.     This might break the VideoState code: if V7 and VESA was enabled
  469.     at start-up and later denied, the wrong video call will be
  470.     made. If the program started in an extended video mode,
  471.     returning to DOS won't set the right video mode.
  472.     The above requires a complete application restart, video wise.
  473.   *******************************************************************)
  474.   procedure TResDemoApp.VideoTestsDialog(VT:SpecialVideoTypes);
  475.     {$I CheckVT}
  476.   begin
  477.     if ExecuteDialog(MakeVideoTestDialog, @VT)=cmOK then
  478.     begin
  479.       VideoTypesToCheck:=VT;
  480.       CheckVideoType;
  481.     end;
  482.   end;
  483.  
  484.  
  485.     (*******************************************************************
  486.     *******************************************************************)
  487.  
  488.   var
  489.     ResDemoApp : TResDemoApp;
  490.  
  491. begin
  492.   ResDemoApp.Init;
  493.   ResDemoApp.Run;
  494.   ResDemoApp.StoreCfg;
  495.   ResDemoApp.Done;
  496. end.